home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / Constant / Utils.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  3.4 KB  |  132 lines
  1. package ExtUtils::Constant::Utils;
  2.  
  3. use strict;
  4. use vars qw($VERSION @EXPORT_OK @ISA $is_perl56);
  5. use Carp;
  6.  
  7. @ISA = 'Exporter';
  8. @EXPORT_OK = qw(C_stringify perl_stringify);
  9. $VERSION = '0.01';
  10.  
  11. $is_perl56 = ($] < 5.007 && $] > 5.005_50);
  12.  
  13. =head1 NAME
  14.  
  15. ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant
  16.  
  17. =head1 SYNOPSIS
  18.  
  19.     use ExtUtils::Constant::Utils qw (C_stringify);
  20.     $C_code = C_stringify $stuff;
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. ExtUtils::Constant::Utils packages up utility subroutines used by
  25. ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its
  26. functions are explicitly exportable.
  27.  
  28. =head1 USAGE
  29.  
  30. =over 4
  31.  
  32. =item C_stringify NAME
  33.  
  34. A function which returns a 7 bit ASCII correctly \ escaped version of the
  35. string passed suitable for C's "" or ''. It will die if passed Unicode
  36. characters.
  37.  
  38. =cut
  39.  
  40. # Hopefully make a happy C identifier.
  41. sub C_stringify {
  42.   local $_ = shift;
  43.   return unless defined $_;
  44.   # grr 5.6.1
  45.   confess "Wide character in '$_' intended as a C identifier"
  46.     if tr/\0-\377// != length;
  47.   # grr 5.6.1 moreso because its regexps will break on data that happens to
  48.   # be utf8, which includes my 8 bit test cases.
  49.   $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56;
  50.   s/\\/\\\\/g;
  51.   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
  52.   s/\n/\\n/g;        # Ensure newlines don't end up in octal
  53.   s/\r/\\r/g;
  54.   s/\t/\\t/g;
  55.   s/\f/\\f/g;
  56.   s/\a/\\a/g;
  57.   if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
  58.       s/([[:^print:]])/sprintf "\\%03o", ord $1/ge;
  59.   } else {
  60.       s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
  61.   }
  62.   unless ($] < 5.006) {
  63.     # This will elicit a warning on 5.005_03 about [: :] being reserved unless
  64.     # I cheat
  65.     my $cheat = '([[:^print:]])';
  66.     s/$cheat/sprintf "\\%03o", ord $1/ge;
  67.   } else {
  68.     require POSIX;
  69.     s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
  70.   }
  71.   $_;
  72. }
  73.  
  74. =item perl_stringify NAME
  75.  
  76. A function which returns a 7 bit ASCII correctly \ escaped version of the
  77. string passed suitable for a perl "" string.
  78.  
  79. =cut
  80.  
  81. # Hopefully make a happy perl identifier.
  82. sub perl_stringify {
  83.   local $_ = shift;
  84.   return unless defined $_;
  85.   s/\\/\\\\/g;
  86.   s/([\"\'])/\\$1/g;    # Grr. fix perl mode.
  87.   s/\n/\\n/g;        # Ensure newlines don't end up in octal
  88.   s/\r/\\r/g;
  89.   s/\t/\\t/g;
  90.   s/\f/\\f/g;
  91.   s/\a/\\a/g;
  92.   unless ($] < 5.006) {
  93.     if ($] > 5.007) {
  94.     if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
  95.         s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge;
  96.     } else {
  97.         s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
  98.     }
  99.     } else {
  100.       # Grr 5.6.1. And I don't think I can use utf8; to force the regexp
  101.       # because 5.005_03 will fail.
  102.       # This is grim, but I also can't split on //
  103.       my $copy;
  104.       foreach my $index (0 .. length ($_) - 1) {
  105.         my $char = substr ($_, $index, 1);
  106.         $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char;
  107.       }
  108.       $_ = $copy;
  109.     }
  110.     # This will elicit a warning on 5.005_03 about [: :] being reserved unless
  111.     # I cheat
  112.     my $cheat = '([[:^print:]])';
  113.     s/$cheat/sprintf "\\%03o", ord $1/ge;
  114.   } else {
  115.     # Turns out "\x{}" notation only arrived with 5.6
  116.     s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge;
  117.     require POSIX;
  118.     s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge;
  119.   }
  120.   $_;
  121. }
  122.  
  123. 1;
  124. __END__
  125.  
  126. =back
  127.  
  128. =head1 AUTHOR
  129.  
  130. Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  131. others
  132.